perm filename EPUTS2.2[EAL,HE]2 blob
sn#701214 filedate 1983-03-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Editor: Statement printing routine Aux routines }
C00023 00003 { Externally defined routines from elsewhere: }
C00025 00004 (* putStmnt aux routine to handle some more of the statement types *)
C00033 00005 (* putst2: main part *)
C00039 ENDMK
C⊗;
{$NOMAIN Editor: Statement printing routine Aux routines }
const
(* Constants from EDIT *)
maxLines = 28; (* smaller on the 11 than on the 10 *)
maxPPLines = 18;
maxBpts = 25;
maxTBpts = 20; (* max could be exceeded by huge case stmnt *)
listinglength = 2000; (* Length of Listingarray *)
(* Random type declarations for OMSI/SAIL compatibility *)
type
byte = 0..255; (* doesn't really belong here, but... *)
ascii = char;
atext = text;
{ Define all the pointer types here }
strngp = ↑strng;
statementp = ↑statement;
varidefp = ↑varidef;
nodep = ↑node;
identp = ↑ident;
reswordp = ↑resword;
pdbp = ↑pdb;
envheaderp = ↑envheader;
enventryp = ↑enventry;
environp = ↑environment;
cmoncbp = ↑cmoncb;
linerecp = ↑linerec;
cursorpp = ↑cursorp; {Ron's style, not mine}
(* This one is used whenever a pointer is needed for which the *)
(* definition is missing from this file; naturally, all *)
(* pointers use the same space *)
dump = ↑integer;
token = array[1..4] of integer;
(* datatype definitions *)
datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
frametype, eventtype, strngtype, labeltype, proctype, arraytype,
reftype, valtype, cmontype, nulltype, undeftype,
dimensiontype, mactype, macargtype, freevartype);
scalar = real;
cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
c5str = packed array [1..5] of ascii;
c20str = packed array [1..20] of ascii;
linestr = packed array [1..130] of ascii;
strng = record
next: strngp;
ch: cstring;
end;
(* statement definitions *)
stmntypes = (progtype, blocktype, coblocktype, endtype, coendtype,
fortype, iftype, whiletype, untiltype, casetype,
calltype, returntype,
printtype, prompttype, pausetype, aborttype, assigntype,
signaltype, waittype, enabletype, disabletype, cmtype,
affixtype, unfixtype,
movetype, operatetype, opentype, closetype, centertype,
stoptype, retrytype,
requiretype, definetype, macrotype, commenttype, dimdeftype,
setbasetype, wristtype, tovaltype, declaretype, emptytype);
(* more??? *)
statement = packed record
next, last: statementp; (* ↑ to lexical tokens? *)
stlab: varidefp;
exprs: nodep; (* any expressions used by this statement *)
nlines: integer;
bpt: boolean;
case stype: stmntypes of
movetype,
operatetype,
opentype,
closetype,
centertype,
stoptype: (cf, clauses: nodep);
cmtype: (oncond: nodep; conclusion: statementp;
deferCm, exprCm: boolean; cdef: varidefp);
end;
(* auxiliary definitions: variable, etc. *)
varidef = packed record
next,dnext: varidefp;
name: identp;
level: 0..255; (* environment level *)
offset: 0..255; (* environment offset *)
dtype: varidefp; (* to hold the dimension info *)
tbits: 0..15; (* special type bits: array = 1, proc = 2, ref = 4 & ? *)
dbits: 0..15; (* for use by debugger/interpreter *)
case vtype: datatypes of
arraytype: (a: nodep);
proctype: (p: nodep);
labeltype,
cmontype: (s: statementp);
mactype: (mdef: statementp);
macargtype: (marg: dump);
pconstype: (c: nodep);
dimensiontype: (dim: nodep);
end;
(* definition of the ubiquitous NODE record *)
nodetypes = (exprnode, leafnode, listnode, clistnode, colistnode, forvalnode,
deprnode, viaptnode, apprnode, destnode, durnode,
sfacnode, wobblenode, swtnode, nullingnode, wristnode, cwnode,
arrivalnode, departingnode,
ffnode, forcenode, stiffnode, gathernode, cmonnode, errornode,
calcnode, arraydefnode, bnddefnode, bndvalnode,
waitlistnode, procdefnode, tlistnode, dimnode, commentnode);
exprtypes = ( svalop, (* scalar operators *)
sltop, sleop, seqop, sgeop, sgtop, sneop, (* relations *)
notop, orop, xorop, andop, eqvop, (* logical *)
saddop, ssubop, smulop, sdivop, snegop, sabsop, (* scalar ops *)
sexpop, maxop, minop, intop, idivop, modop,
sqrtop, logop, expop, timeop, (* functions *)
sinop, cosop, tanop, asinop, acosop, atan2op, (* trig *)
vdotop, vmagnop, tmagnop,
vecop, (* vector operators *)
vmakeop, unitvop, vaddop, vsubop, crossvop, vnegop,
svmulop, vsmulop, vsdivop, tvmulop, wrtop,
tposop, taxisop,
transop, (* trans operators *)
tmakeop, torientop, ttmulop, tvaddop, tvsubop, tinvrtop,
vsaxwrop, constrop, ftofop, deproachop, fmakeop, vmkfrcop,
ioop, (* i/o operators *)
queryop, inscalarop,
specop, (* special operators *)
arefop, callop, grinchop, macroop, vmop, adcop, dacop,
badop,
addop, subop, negop, mulop, divop, absop); (* for parsing *)
leaftypes = pconstype..strngtype;
reltypes = sltop..sgtop;
forcetypes = (force,absforce,torque,abstorque,angvelocity);
node = record
next: nodep;
case ntype: nodetypes of
exprnode: (op: exprtypes; arg1, arg2, arg3: nodep; elength: integer);
leafnode: (case ltype: leaftypes of
varitype: (vari: varidefp; vid: identp);
pconstype: (cname: varidefp; pcval: nodep);
svaltype: (s: scalar; wid: integer);
vectype: (v: dump);
transtype: (t: dump);
strngtype: (length: integer; str: strngp) ); (* also used by commentnodes *)
errornode: (eexpr: nodep);
deprnode,
apprnode,
destnode: (loc: nodep; code: statementp);
viaptnode: (vlist: boolean; via,duration,velocity: nodep; vcode: statementp);
durnode: (durrel: reltypes; durval: nodep);
sfacnode,
wobblenode,
swtnode: (clval: nodep);
nullingnode,
wristnode,
cwnode: (notp: boolean); (* true = nonulling/zero wrist/counter_clockwise *)
ffnode: (ff: nodep; csys, pdef: boolean); (* true = world, false = hand *)
forcenode: (ftype: forcetypes; frel: reltypes; fval, fvec, fframe: nodep);
stiffnode: (fv, mv, coc: nodep);
gathernode: (gbits: integer);
cmonnode: (cmon: statementp; errhandlerp: boolean);
calcnode: (rigid, frame1: boolean; other: dump; case tvarp: boolean of
false: (tval: dump); true: (tvar: enventryp) );
end;
(* records for parser: ident, token, resword *)
ident = record
next: identp;
length: integer;
name: strngp;
predefined: varidefp;
end;
tokentypes = (reswdtype, identtype, constype, comnttype, delimtype, labeldeftype,
macpartype);
constypes = svaltype..strngtype;
reswdtypes = (stmnttype, filtype, clsetype, decltype, optype, edittype);
filtypes = (abouttype,alongtype,attype,bytype,defertype,dotype,elsetype,
errmodestype,fromtype,handtype,intype,nonrigidlytype,rigidlytype,
sourcefiletype,steptype,thentype,totype,untltype,viatype,
withtype,worldtype,zeroedtype,oftype,wheretype,nowaittype,
ontype,offtype,ppsizetype,collecttype,alltype,lextype);
clsetypes = (approachtype,arrivaltype,departuretype,departingtype,durationtype,
errortype,forcetype,forceframetype,forcewristtype,gathertype,
nildeproachtype,nonullingtype,nullingtype,stiffnesstype,
torquetype,velocitytype,wobbletype,
cwtype,ccwtype,stopwaittimetype,angularvelocitytype,
fxtype,fytype,fztype,mxtype,mytype,mztype,
t1type,t2type,t3type,t4type,t5type,t6type,tbltype);
edittypes = (getcmd,savecmd,insertcmd,renamecmd,startcmd,gocmd,proceedcmd,
stepcmd,sstepcmd,nstepcmd,gstepcmd,executecmd,setcmd,tracecmd,
breakcmd,unbreakcmd,tbreakcmd,definecmd,markcmd,unmarkcmd,
popcmd);
resword = record
next: reswordp;
length: integer;
name: strngp;
case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
edittype: (ed: edittypes);
end;
(* process descriptor blocks & environment record definitions *)
queuetypes = (nullqueue,nowrunning,runqueue,inputqueue,eventqueue,sleepqueue,
forcewait,devicewait,joinwait,proccall);
pdb = packed record
nextpdb,next: pdbp; (* for list of all/active pdb's *)
level: 0..255; (* lexical level *)
mode: 0..255; (* expression/statement/sub-statement *)
priority: 0..255;
status: queuetypes; (* what are we doing *)
env: envheaderp;
spc: statementp; (* current statement *)
epc: nodep; (* current expression (if any) *)
sp: nodep; (* intermediate value stack *)
cm: cmoncbp; (* if we're a cmon point to our definition *)
mech: dump; (* current device being used *)
linenum: integer; (* used by editor/debugger *)
case procp: boolean of (* true if we're a procedure *)
true: (opdb: pdbp; (* pdb to restore when procedure exits *)
pdef: nodep); (* procedure definition node *)
false: (evt: dump; (* event to signal when process goes away *)
sdef: statementp); (* first statement where process was defined *)
end;
envheader = packed record
parent: envheaderp;
env: array [0..4] of environp;
varcnt: 0..255; (* # of variables in use ??? *)
case procp: boolean of (* true if we're a procedure *)
true: (proc: nodep);
false:(block: statementp);
end;
enventry = record
case etype: datatypes of
svaltype: (s: scalar);
vectype: (v: dump);
transtype: (t: dump);
frametype: (f: dump);
eventtype: (evt: dump);
strngtype: (length: integer; str: strngp);
cmontype: (c: cmoncbp);
proctype: (p: nodep; penv: envheaderp);
reftype: (r: enventryp);
arraytype: (a: envheaderp; bnds: nodep);
end;
environment = record
next: environp;
vals: array [0..9] of enventryp;
end;
cmoncb = record
running, enabled: boolean; (* cmon's status *)
cmon: statementp;
pdb: pdbp;
evt: dump;
fbits: integer; (* bits for force sensing *)
oldcmon: cmoncbp; (* for debugger *)
end;
(* print related records: *)
cursorp = record
cline,ind: integer;
case stmntp: boolean of
true: (st: statementp);
false: (nd: nodep);
end;
linerec = record
next: linerecp;
start,length: integer
end;
listingarray = packed array [0..listinglength] of ascii;
(* Global variables *)
var
(* From ALMAIN *)
b:boolean;
ch:ascii;
ltime: real;
(* From PARSE *)
reswords: array [0..26] of reswordp;
idents: array [0..26] of identp;
macrostack: array [1..10] of dump;
curmacstack: array [1..10] of varidefp;
macrodepth: integer;
curchar, maxchar, curline: integer;
curBlock,newDeclarations: statementp;
curProc: varidefp;
pnode: nodep;
nodim, distancedim, timedim, angledim,
forcedim, torquedim, veldim, angveldim: varidefp;
fvstiffdim, mvstiffdim: nodep;
(* filedepth: integer;
curpage: integer;
sysVars,unVars: varidefp;
errcount: integer;
outerBlock: statementp;
curVariable: varidefp;
curMotion: statementp;
endOk,coendOk: integer;
moveLevel: integer;
curErrhandler, curCmon: statementp; *)
d1: array[1..13] of dump;
endOfLine, backup, expandmacros, flushcomments, dimCheck: boolean;
(* semiseen, shownline: boolean;
eofError: boolean;
inMove,inCoblock: boolean; *)
d2,d3,d4,d5,d6: boolean;
curtoken: token;
file1,file2,file3,file4,file5: atext;
line: linestr;
(* From INTERP *)
curInt, activeInts, readQueue, allPdbs: pdbp;
(* curEnv, sysEnv: envheaderp;
clkQueue: nodep;
allEvents: dump;
STLevel: integer;
etime: integer;
curtime: integer;
stime: integer;
msg: dump;
inputp: integer; *)
d10: array[1..10] of integer;
debugLevel: integer;
tSingleThreadMode: boolean;
resched, running, escapeI, singleThreadMode: boolean;
msgp: boolean; (* flag set if any messages pending *)
inputReady: boolean;
inputLine: array [1..20] of ascii;
(* From EDIT *)
lines: array [1..maxLines] of linerecp;
ppLines: array [1..maxPPLines] of linerecp;
marks: array [1..20] of integer;
cursorStack: array [1..15] of cursorp;
bpts: array [1..maxBpts] of statementp;
tbpts: array [1..maxTBpts] of statementp;
debugPdbs: array [0..10] of pdbp;
screenheight,dispHeight: integer;
ppBufp,oppBufp,ppOffset,ppSize,nmarks: integer;
lbufp,cursor,ocur,cursorLine,fieldnum,lineNum,findLine,pcLine: integer;
firstDline,topDline,botDline,firstLine,lastLine: integer;
freeLines,oldLines: linerecp;
findStmnt: statementp;
nbpts,ntbpts: integer;
eCurInt: pdbp;
dProg: statementp;
smartTerminal: boolean;
setUp,setExpr,setCursor,dontPrint,outFilep,newVarOk,collect: boolean;
backUp: boolean;
eSingleThreadMode: boolean;
listing: listingarray;
lbuf: array [1..160] of ascii;
ppBuf: array [1..100] of ascii;
outFile: atext;
curToken: token;
(* Various device & variable pointers *)
speedfactor: enventryp;
barm: dump;
(* Various constant pointers *)
xhat,yhat,zhat,nilvect: dump;
niltrans: dump;
bpark, ypark, gpark, rpark: dump; (* arm park positions *)
{ Externally defined routines from elsewhere: }
(* From EAUX1A *)
procedure pushStmnt(s: statementp; indent: integer); external;
procedure pushNode(n: nodep); external;
(* From EPUT *)
procedure putChar(ch: ascii); external;
procedure put5(ch: c5str; length: integer); external;
procedure put10(ch: cstring; length: integer); external;
procedure putLine; external;
procedure putReal(s: real); external;
procedure putInt(r: real); external;
procedure putStrng(length: integer; s: strngp); external;
function getExprLength(n: nodep): integer; external;
(* From EPUTST *)
procedure putexpr(n: nodep; opp: integer); external;
procedure newline(indent: integer); external;
procedure outExpr(n: nodep); external;
(* From EROOT *)
procedure ep2putstmnt(s: statementp; indent, plevel: integer); external;
procedure ePs2Get; external;
procedure ePs2Get; begin end;
(* putStmnt aux routine to handle some more of the statement types *)
procedure putst2(s: statementp; indent, plevel: integer; var l: integer); external;
procedure putst2;
var i: integer; n,nv: nodep; b: boolean;
(* Aux routines: *)
function codeLength(st: statementp): integer;
begin
if st↑.stype = signaltype then codeLength := 1
else codeLength := st↑.conclusion↑.nlines;
end;
procedure putClause(cl: nodep);
var cnt, bits: integer; b: boolean;
begin
with cl↑ do
case ntype of
durnode: begin
put10('duration ',9);
if durrel <= sleop then put5('<= ',3)
else if durrel = seqop then putchar('=')
else put5('>= ',2);
outExpr(durval);
end;
velocitynode,
wobblenode,
sfacnode,
swtnode:
begin
if ntype = sfacnode then
begin put10('speed_fact',10); put5('or = ',5) end
else if ntype = wobblenode then put10('wobble = ',9)
else if ntype = velocitynode then
begin put10('velocity =',10); putChar(' ') end
else begin put10('stop_wait_',10); put10('time = ',7) end;
outExpr(clval);
end;
loadnode:begin
put10('load = ',7);
outExpr(loadval);
if loadvec <> nil then
begin
put5(' at ',4);
outExpr(loadvec);
end;
if lcsys then put10(' in world ',9)
else put10(' in hand ',8);
end;
elbownode:
begin
put5('elbow',5);
if notp then put5(' up ',3) else put5(' down',5);
end;
shouldernode:
begin
if notp then put5('right',5) else put5('left ',4);
put10(' shoulder ',9);
end;
linearnode:
begin
if notp then put10('linear ',7)
else begin put10('joint_spac',10); put5('e ',2) end;
put10('motion ',6);
end;
flipnode,
nullingnode:
begin
if notp then put5('no ',3);
if ntype = flipnode then put5('flip ',4) else put10('nulling ',7);
end;
cwnode:
begin
if notp then put10('counter_ ',8);
put10('clockwise ',9);
end;
wrtnode: begin
put10('respect to',10); putChar(' ');
outExpr(loc);
end;
apprnode,
deprnode:begin
if ntype = apprnode then put10('approach ',8)
else put10('departure ',9);
put5(' = ',3);
if loc = nil then begin put10('nildeproac',10); putchar('h') end
else outExpr(loc);
if code <> nil then
begin
put5(' then',5);
if code↑.stype = signaltype then ep2PutStmnt(code,indent+4,plevel)
else ep2PutStmnt(code↑.conclusion,indent+4,plevel);
end;
end;
wristnode:
begin
put10('force_wris',10); put5('t ',2);
if notp then put5('not ',4);
put10('zeroed ',6);
end;
ffnode: begin
put10('force_fram',10); put5('e = ',4);
outExpr(ff);
if csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
forcenode:
begin
case ftype of
force: put5('force',5);
absforce: put10('|force| ',7);
torque: put10('torque ',6);
abstorque: put10('|torque| ',8);
angvelocity: begin put10('angular_ve',10); put10('locity ',6) end;
otherwise {do nothing - ??};
end;
if frel <= sleop then put5(' < ',3)
else if frel = seqop then put5(' = ',3)
else put5(' >= ',4);
outExpr(fval);
if fvec <> nil then
begin
if ftype <= absforce then put10(' along ',7)
else put10(' about ',7);
outExpr(fvec);
end;
if fframe <> nil then
begin
put5(' of ',4);
outExpr(fframe↑.ff);
if fframe↑.csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
end;
stiffnode:
begin
put10('stiffness ',10); put5('= ( ',3);
if (fv↑.ntype = exprnode) and (fv↑.op = vmakeop) and
(mv↑.ntype = exprnode) and (mv↑.op = vmakeop) then (* 6 scalar form *)
begin
outExpr(fv↑.arg1);
putchar(',');
outExpr(fv↑.arg2);
putchar(',');
outExpr(fv↑.arg3);
putchar(',');
outExpr(mv↑.arg1);
putchar(',');
outExpr(mv↑.arg2);
putchar(',');
outExpr(mv↑.arg3);
end
else
begin
outExpr(fv);
putchar(',');
outExpr(mv);
end;
putchar(')');
if cocff <> nil then
begin
put10(' about ',7);
outExpr(cocff↑.ff);
if cocff↑.csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
end;
gathernode:
begin
put10('gather = (',10);
bits := gbits;
cnt := 0;
while bits <> 0 do
begin
b := false;
if odd(bits) then
if cnt = 12 then put5('tbl ',3)
else
begin
if cnt >= 6 then
begin
putchar('t');
putchar(chr(ord('1') + cnt - 6));
end
else
begin
if cnt <= 2 then putchar('f') else putchar('m');
putchar(chr(ord('x') + cnt mod 3));
end;
b := true;
end;
bits := bits div 2;
cnt := cnt + 1;
if b and (bits <> 0) then putchar(',');
end;
putchar(')');
end;
otherwise {do nothing};
end;
end;
(* putst2: main part *)
begin
with s↑ do
case stype of
cmtype: begin
if deferCm then put10('defer on ',9)
else put5('on ',3);
with oncond↑ do
if (ntype = exprnode) or (ntype = leafnode) then outExpr(oncond)
else if ntype = arrivalnode then put10('arrival ',7)
else if ntype = departingnode then put10('departing ',9)
else if ntype = errornode then
begin
put10('error = ',8);
outExpr(eexpr);
end
else putClause(oncond);
put5(' do ',3);
ep2PutStmnt(conclusion,indent+2,plevel);
end;
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype,
floattype: begin
if (stype = movetype) or (stype = jtmovetype) then put5('move ',5)
else if stype = operatetype then put10('operate ',8)
else if stype = opentype then put5('open ',5)
else if stype = closetype then put10('close ',6)
else if stype = centertype then put10('center ',7)
else put10('float ',6);
outExpr(cf);
n := clauses;
if n <> nil then
with n↑ do
if (ntype = ffnode) and pdef then n := next;
if n = nil then b := false
else b := n↑.ntype = destnode; (* print it on same line *)
if b then putchar(' ');
while n <> nil do (* print out the clauses *)
with n↑ do
begin
if not ((((ntype=viaptnode) or (ntype=byptnode)) and vlist)
or b) then
begin
if setCursor then
begin
if (ntype = viaptnode) or (ntype = byptnode) then
begin
i := 1;
nv := vclauses;
while nv <> nil do
begin i := i + 1; nv := nv↑.next end;
if vcode <> nil then i := codeLength(vcode) + i + 1;
end
else if ((ntype = deprnode) or (ntype = apprnode)) and
(code <> nil) then i := codeLength(code) + 2
else if ntype = cmonnode then i := cmon↑.nlines
else i := 1;
if (curLine < cursorLine) and
(cursorLine <= curLine + i) then
begin
pushNode(n);
cursorStack[cursor].ind := indent + 2;
end;
end;
if ntype <> cmonnode then newline(indent+2);
end;
b := false;
if ntype = destnode then
begin
put5('to ',3);
outExpr(loc);
end
else if (ntype = viaptnode) or (ntype = byptnode) then
begin
if vlist then put5(', ',2)
else if ntype = viaptnode then put5('via ',4)
else put5('by ',3);
outExpr(via);
nv := vclauses;
i := 2;
while nv <> nil do
begin
newline(indent+4);
if curLine = cursorLine then fieldNum := i;
put10('where ',6);
putClause(nv);
i := i + 1;
nv := nv↑.next;
end;
if vcode <> nil then
begin
newline(indent+4);
if curLine = cursorLine then fieldNum := i;
put5('then ',4);
if vcode↑.stype = signaltype then
ep2PutStmnt(vcode,indent+6,plevel)
else ep2PutStmnt(vcode↑.conclusion,indent+6,plevel);
end;
end
else if ntype = cmonnode then
begin
ep2PutStmnt(cmon,indent+2,plevel);
end
else if ntype = commentnode then
begin
putStrng(length,str);
end
else
begin
if (ntype <> ffnode) or (not pdef) then
begin
if ntype <> cwnode then put5('with ',5);
putClause(n);
end;
end;
n := next;
end;
end;
(* more??? *)
else begin put10('Oh no! 2 ',10); put10('Bad ovlay!',10); end;
end;
end;